Dictionaries & Language/Dictionaries and Language (Chestnut CD-ROM) (1993).iso/misc/fl_tut2/compu2tr.pas

Pascal/Delphi Source File | 1987-06-11 | 20.4 KB | 884 lines

 {$R-}
Program compu2tr;
var
   ami:integer;

function ColorMonitor:boolean;
{returns TRUE if a Color monitor is installed}
type regpack = record
       ax,bx,cx,dx,bp,si,di,ds,es,flags:integer;end;
var regs:regpack;
   al:integer;
begin
regs.ax:=15 shl 8;
intr($10,regs);
al:=Lo(regs.ax);
if al=$7 then ColorMonitor:=false else ColorMonitor:=true;
end;


procedure Title_Screen;
          var
             mark, x :integer;

begin {start title_screen}

      textcolor(0);
      if colormonitor then
                 textbackground(14)
      else textbackground (1);


      x:=0;
      gotoxy(23,22);
      write('█████████████████████████████');

      for x:=1 to 11 do
      begin
           gotoxy(32,10+x);
           write('█         █');
      end;

      gotoxy(12,10);write('████████████████████████████████████████████████████');

      For x:=1 to 3 do
      begin
           gotoxy(12,6+x);write('█                   █         █                    █');
      end;

      gotoxy(12,6);write('█████████████████████         ██████████████████████');
      gotoxy(16,8);write(' C  O  M  P');
      gotoxy(45,8);write(' T  U  T  O  R');
      gotoxy(31,5);write('█  ─╥  ╥─   █');gotoxy(34,6);write(' ║  ║');
      gotoxy(35,7);    write('║  ║');     gotoxy(34,8);write(' ╚══╝');
      gotoxy(12,24);write('by Elaine and Ken Woodward for the Boston Public Schools.');


end;{end of title_screen}


Procedure PullDownMenus;

const

       MaxItems=6; {Max Items on a Menu Bar}
       MaxMenus=10; {Max Menus}
       Width=21;    {Width of Pull Down Fields}

Type

   VideoMode =(Norm,Rev,Hi,Und,RevHi,Blink,BlinkHi,RevBlink,RevBlinkHi);
   MaxString = String[255];
   stringW = string[Width];


   ProtoMenu = record
        NumEntry :array[0..MaxItems] of integer;
        Menu:array[0..MaxItems] of array[0..MaxItems] of stringW;
        MenuName:stringW;
        NoItems:integer;
        end;

   MenuPtr = ^ProtoMenu;

   MenuAry =  array[1..MaxMenus] of MenuPtr;

var

i,NumMenus:integer;
Menus:MenuAry;
exit:boolean;
VideoSeg:integer;{points to $B000 or $B800  for color or mono}
botbox:maxstring;


function ColorMonitor:boolean;
{returns TRUE if a Color monitor is installed}
type regpack = record
       ax,bx,cx,dx,bp,si,di,ds,es,flags:integer;end;
var regs:regpack;
   al:integer;
begin
regs.ax:=15 shl 8;
intr($10,regs);
al:=Lo(regs.ax);
if al=$7 then ColorMonitor:=false else ColorMonitor:=true;
end;


Procedure SetVideoSeg;
begin
if colormonitor then VideoSeg:=$B800 else VideoSeg:=$B000
end;


Procedure SetCursor(HiScan,LowScan:byte);
type regpack = record
       ax,bx,cx,dx,bp,si,di,ds,es,flags:integer;end;
var regs:regpack;
begin
regs.ax:=1 shl 8;
regs.cx:=HiScan shl 8 + LowScan;
intr($10,regs);
end;


Procedure CursorNormal;
begin
if ColorMonitor then SetCursor(6,7) else  SetCursor(10,11);
end;


Procedure CursorBlock;
begin
if ColorMonitor then SetCursor(1,7) else  SetCursor(1,14);
end;


Procedure CursorOff;
begin
SetCursor(31,0);
end;




procedure GetKb(var chcode,extcode:integer);

(*Obtains the character and extended codes of a struck key. The codes are
 removed from the buffer. This procedure will wait for a keystrike if the
 buffer is empty.*)

type
  RegPack = record
       ax,bx,cx,dx,di,si,ds,es,flags : integer;
     end;
var
  regs:RegPack;

begin
  regs.ax := $0000;
  intr($16,regs);
  extcode := regs.ax shr 8;   ; (*extended code is AH*)
  chcode := regs.ax and $00FF;    (*character code is AL*)
end;


function inchar(var ch:char;var ex:integer):boolean;{true if ASCII char}
{Returns char and extended code from keyboard}
var chcode,excode:integer;
begin
getkb(chcode,ex);
if chcode=0 then
    begin
    inchar:=false;
    ch:=chr(ex);
    end
else
    begin
    ch:=chr(chcode);
    inchar:=true;
    if ex<>0 then
      if chcode in [8,13,9,27] then
  begin
  ex:=chcode;
  inchar:=false;
  end;
    end;
end;{inchar}

procedure Writeat(x,y:integer;writeMode:Videomode;Thestring:maxstring);

Var
  i,j,k:integer;
  Attribute:Byte;

Begin{1}
  case WriteMode of {change these for color terminals}
   Norm:       Attribute := $07;
   Rev:        Attribute := $70;
   Hi:         Attribute := $0F;
   Und:        Attribute := $01;
   RevHi:      Attribute := $78;
   Blink:      Attribute := $87;
   BlinkHi:    Attribute := $8F;
   RevBlink:   Attribute := $F0;
   RevBlinkHi: Attribute := $F8;
   ELSE        Attribute := $07;{Normal}
   end;


   j := 2*((y-1)*80+(x-1));{offset in video buffer}
   i:=1;
   k:=length(thestring);
   While i<=k do
       begin
       Mem[VideoSeg : j] := Byte(TheString[i]);
       Mem[VideoSeg : (j+1)] := Attribute;
       i:=i+1;
       j:=j+2;
       end;
end;{1 of WriteAt}



Procedure LoadMenus(var MenuList:MenuAry);
{loads the menu data file}
var mark,i,j,k:integer;
    f:text;
    s:maxstring;

Procedure GetAMenu(var M:MenuPtr);
label 99;
var i,j,k:integer;
begin
i:=-1;
j:=0;
{ s has been primed }
M^.MenuName:=s;
readln(f,s);
s:=s+'           ';
while (s[1]<>'*') and (not eof(f)) do
   begin

   if s[1]<>' ' then
     begin
     if i>=0 then M^.NumEntry[i]:=j;
     i:=i+1;
     M^.Menu[i,0]:=s;
     j:=0;
     end

   else
     if s[1]<>'*' then
       begin
       j:=j+1;
       delete(s,1,1);
       M^.Menu[i,j]:=s;
       end
     else goto 99;


  readln(f,s);
  s:=s+'            ';

  end;

99:
M^.NumEntry[i]:=j;
M^.NoItems:=i;

end;{GetAMenu}

begin{Load}

    assign(f,'fl-menu.dat'); {**menu data file**}

reset(f);

i:=0;
readln(f,s);

while not eof(f) do
   begin
   i:=i+1;
   New(Menus[i]);
   GetAMenu(Menus[i]);
   end;
NumMenus:=i;

close(f);

{some other initialization here}

botbox:='╚';
for i:=1 to Width do botbox:=botbox+'═';
botbox:=botbox+'╝';

end;{LoadMenu}




procedure DoMenu(var itemsel,entrysel:integer;M:MenuPtr);

{this runs a menu, reads keys etc,}
{itemsel and entrysel are returned}


type
   setofkeys=set of 0..132;

var
   chc,ex:integer;
   ch:char;
   validkeys:setofkeys;
   asc,selection:boolean;
   item,entry:integer;
   s1,s2:maxstring;


Procedure PaintMenuBar;
var
i,sx:integer;
widebar:integer;
begin

clrscr;


for widebar:=1 to 3 do
    begin
    writeat(1,widebar,rev,'                                                                                ');
    end;

writeat(1,3,RevHi,'________________________________________________________________________________');
for i:=0 to M^.NoItems do
   begin
   sx:=7+i*Width;
   writeat(sx,2,rev,M^.Menu[i,0]);
   end;
end;{PaintMenuBar}


Procedure Bright(ix,ij:integer);
var sx:integer;
    s:maxstring;
begin
s:=M^.Menu[ix,ij];
sx:=ix*Width+4;
writeat(sx+1,ij+3,Rev,s)
end;



Procedure UnderScore(ix,ij:integer);
var sx:integer;
    s:maxstring;
begin
sx:=ix*Width+4;
s:=M^.Menu[ix,ij];
writeat(sx+1,ij+3,Und,s)
end;


Procedure Normal(ix,ij:integer);
var sx:integer;
    s:maxstring;
begin
sx:=ix*Width+4;
if ij=0 then if sx<1 then sx:=1;
s:=M^.Menu[ix,ij];
writeat(sx+1,ij+3,Norm,s)
end;



Procedure PushUp(ix:integer);
var sx,i:integer;
begin
sx:=ix*Width+4;
if sx<1 then sx:=1;
for i:=1 to M^.NumEntry[ix]+1 do
   writeat(sx,i+3,Norm,'                         ');
end;

Procedure PullDown(ix:integer);
const

    l:maxstring='║';
    r:maxstring='║';
var sx:integer;
    s:maxstring;
    j:integer;
begin
sx:=ix*Width+4;
for j:=1 to M^.NumEntry[ix] do
    begin
    s:=l+'                     '+r;
    writeat(sx,j+3,Norm,s);
    s:=M^.Menu[ix,j];
    writeat(sx+2,j+3,Norm,s);
    end;
if M^.NumEntry[ix]>0 then writeat(sx,M^.NumEntry[ix]+4,Norm,botbox);
end;


begin {DoMenu}

CursorOff;

validkeys:=[13,15,75,9,77,80,72,27];

entry:=1;
item:=0;
PaintMenuBar;
PullDown(0);
Bright(item,entry);

selection:=FALSE;

while not selection do
   begin

   asc:= Inchar(ch,ex);

   if ex=0 then {Ctl-Brk hit}
      begin
      CursorNormal;
      clrscr;
      halt;
      end;

   if not asc then
   case ex{tended code} of

   13:{CR}
      selection:=TRUE;


      15, 75:{lefttab,left}
      if item>0 then
        begin
        item:=item-1;
        entry:=1;
        pushup(item+1);
        pulldown(item);
        Bright(item,entry);
        end;

       9, 77:{tab,right}
      if item<M^.NoItems then
        begin
        item:=item+1;
        entry:=1;
        pushup(item-1);
        pulldown(item);
        entry:=1;
        Bright(item,1);
        end;

   80:{down}
      begin
      if entry<M^.NumEntry[item] then
  begin
  entry:=entry+1;
  Normal(item,entry-1);
  Bright(item,entry);
  end
      else
        begin
        entry:=1;
        Normal(item,M^.NumEntry[item]);
        Bright(item,entry);
        end;
      end;

   72:{up}
      begin
      if entry>1 then
  begin
  entry:=entry-1;
  Normal(item,entry+1);
  Bright(item,entry);
  end
      else
        begin
        entry:=M^.NumEntry[item];
        Normal(item,1);
        Bright(item,entry);
        end;
      end;
   27:{Esc}
        begin
        selection:=TRUE;
        item:=0;
        entry:=0;
        end;

   end;{case}

   end;{while not selection}
itemsel:=item;
entrysel:=entry;

CursorNormal;

end;{DoMenu}



Procedure RunMenus;

{  Skeleton Procedure that you flesh out to run your menu tree.}

var
exit:boolean;
ch:char;
Active,index,item,entry:integer;

begin {RunMenu}

exit:=FALSE;
Active:=1;

while not exit do
  begin

  DoMenu(item,entry,Menus[Active]);

  index:=Active*100+item*10+entry;

  case index of {fill this in appropriately with structure}

  211,311: begin
Active:=1;
end;

  101: begin
 Active:=2; {select next Menu}
 end;

  102: begin
 Active:=3; {select next Menu}
 end;

  110,111: begin
     gotoxy(10,10);
     writeln(' Use the right and left arrow keys to move from one menu to another and the up/down arrows to select items.');
     delay(4000);
     end;


  103,112,212,312: begin
       gotoxy(10,10);
       write(' Do You Really Want to Quit? ');
       readln(ch);
       if ch in ['Y','y'] then exit:=TRUE;
       end;


  212,312:begin
   Active:=1;
   end;

  201,202,203,301,302,303: begin
       clrscr;
       ami:=index;
       exit:=true;
       end;


   end;{case}
end;

end;{RunMenus}



begin{main}

CursorNormal;

SetVideoSeg;
LoadMenus(Menus);
RunMenus;
end; {end of pulldownmenus}




Procedure fl_tutor(ami:integer);

Label 999;
Const
     maxWords=501;
     w=55;


Type
    maxstring=string[255];
    wstring=string[w];


Var
     M,IT,E,z,r,a :integer;
         f :text;
         s :maxstring;
         Word:array[0..maxWords] of wstring;
         Def :array[0..maxwords] of wstring;
         key_ret:char;
         back:boolean;
         new_def:array[0..4] of wstring;
         right,wrong:integer;
         keyset:set of char;
         temp:wstring;

Procedure Draw_screen;
         begin
              gotoxy (3,4);write('╔════════════════════════════════════════════╗');
              gotoxy(3,10);write('╚════════════════════╤═══════════════════════╝');
              gotoxy( 3,5);write('║                                            ║');
              gotoxy (3,6);write('║  Choose the word that means                ║');
              gotoxy (3,7);write('║                                            ║');
              gotoxy (3,8);write('║                        and type it below.  ║');
              gotoxy (3,9);write('║                                            ║');
              gotoxy (24,11);write('│');
              gotoxy (24,12);write('│');
              gotoxy (24,13);write('│');
              gotoxy (24,14);write('│');
              gotoxy (11,15);write('┌────────────┴─────────────┐');
              gotoxy (11,19);write('╘══════════════════════════╛');
              gotoxy (11,16);write('│                          │');
              gotoxy (11,17);write('│                          │');
              gotoxy (11,18);write('│                          │');

         end;

procedure choices;
     VAR
        new_def:string[27];

          begin
               gotoxy (45,16);        write('╓─────────────────────────────────╖');
               gotoxy (38,17); write('╞══════╣       choose from below         ║');
               gotoxy (45,18);       write ('╟─────────────────────────────────╢');
               gotoxy (45,19);       write ('║                                 ║');
               gotoxy (45,20);       write ('║                                 ║');
               gotoxy (45,21);       write ('║                                 ║');
               gotoxy (45,22);       write ('║                                 ║');
               gotoxy (45,23);       write ('║                                 ║');
               gotoxy (45,24);       write ('╙─────────────────────────────────╜');

               if (it)>480 then a:=(it-20)
                  else a:=it;
                  delete(def[a+1],29,10);
                  gotoxy(48,19);write(def[a+1]);
                  delete(def[a+5],29,10);
                  gotoxy(48,20);write(def[a+5]);
                  delete(def[a+10],29,10);
                  gotoxy(48,21);write(def[a+10]);
                  delete(def[a+15],29,10);
                  gotoxy(48,22);write(def[a+15]);
                  delete(def[a+20],29,10);
                  gotoxy(48,23);write(def[a+20]);
               randomize;
               z:=random(4);
               new_def:='                         ';
               insert(def[it],new_def,1);
               delete(def[it],25,10);
               gotoxy(48,19+z);write(new_def);
           end;

procedure answer(it:integer);
      CONST
           sp = ' '; cr = ^M;
           mesg1='Good work!   Tres bien.';
           mesg2='Sorry!  Try again.';
           mesg3='Good work!   ¡Muy bien!';

      VAR
           ch:char;
            t:integer;
         answ:wstring;
         ndef:wstring;
         ddef:wstring;
            S:wstring;


function STRIP ( S : wString):wstring;
                                     { Removes characters other than
                                                    letters  a...z }
var
     space:set of char;
     zz,lngths:integer;
     new_s:wstring;
begin
     lngths:=length(s);
     new_s:=s;
     space:=[chr($39),chr($08),chr($07),chr($09),' ',^M,'@'];
     for zz:=1 to lngths do
         begin
         if new_s[zz] in space then delete(new_s,zz,1);
         end;

     s:=new_s;
     strip:=s;

end;    {strip function ends}


procedure ReadAt(x,y,nchars:integer;var TheString:wstring);
{ performs read from video buffer}
Var
  i,j:integer;
  Attribute:Byte;
  videoseg:integer;

Begin{1}
TheString:='';
   if colormonitor then videoseg:=$B800 else videoseg:=$B000;
   j := 2*((y-1)*80+(x-1));{offset in video buffer}
   i:=1;
   While (i<=nchars) do
       begin{3}
       TheString:=TheString+chr(ord(Mem[VideoSeg:j]));
       i:=i+1;
       j:=j+2;
       end;{3}
end;{1 of ReadAt}


          begin    {answer - main procedure}
             choices;
             s:='';
             gotoxy(15,17);
             answ:='';
             WHILE ch <>cr do
                   begin
                   read(kbd,ch);
                   ch:=upcase(ch);
                   write(ch);
                   readat(15,17,length(def[it]),answ);
                   end;
              ndef:=def[it];
              ddef:='';
              for t:=1 to length(ndef)  do
                  begin
                     ch:=ndef[t];
                     if (ch='à') or (ch='á') then ch:='a';  {translate alt char}
                     if ch='ù' then ch:='u';
                     if (ch='è') or (ch='é') then ch:='e';
                     if ch='í' then ch:='i';
                     if ch='ó' then ch:='o';
                     if ch='ñ' then ch:='n';
                     ch:=upcase(ch);
                     ddef:=ddef+ch;
                  end;

                     s:=ddef;
                     ndef:=strip(s);      {strip spaces }
                     s:='';
                     s:=answ;
                     answ:=strip(s);
              if answ=ndef then
                  begin
                  gotoxy(5,22);
                  if m=2 then write(mesg1)
                     else write (mesg3);
                  write(' - -  corrrect');
                  right:=right+1;
                  delay(1000);
                  exit;
                  end                           {correct response}
               else gotoxy(5,22);write(mesg2);  {incorrect response}
               window(12,16,37,18); textcolor (11);textbackground(0);
               clrscr;
               gotoxy(4,1);write(word[it],' means');
               gotoxy(10,3);write(def[it]);delay (2500);
               window(1,1,80,25);
               wrong:=wrong+1;
               delay(2000);

          end; {finish answer procedure}



          begin  {begin fl-tutor}
            clrscr;
            textcolor(0);textbackground(7);
            m:=trunc(ami/100);
            e:=(ami-(trunc(ami/100)*100));
               if m=2 then                         {*******French Tutor********}
                  if e=1 then assign(f,'fr_tut1.dat') {*level 1*}
                  else
                      if e=2 then assign(f,'fr_tut2.dat') {*level 2*}
                  else
                      assign(f,'fr_tut3.dat') {*level 3*}
               else
                   if m=3 then                      {*********Spanish Tutor**********}
                      if e=1 then assign(f,'sp_tut1.dat'){*level 1*}
                      else
                          if e=2 then assign(f,'sp_tut2.dat') {*level 2*}
                      else
                          assign(f,'sp_tut3.dat'); {*level 3*}
                reset(f);
                it:=0;
                z:=0;
                gotoxy(2,22);write('*** LOADING  LEVEL ',e,' ***');
                  for a:= 1 to 500 do
                      begin
                      readln(f,s);
                      z:=pos(',',s);
                      word[a]:=copy(s,1,z-1);
                      def[a]:=copy(s,z+1,28);
                      end;

               close(f);
               r:=0;
               right:=0;
               wrong:=0;

     999:      while r<16 do

                     begin
                     clrscr;
                     draw_screen;
                     randomize;
                     it:=random(500);
                     if it<1 then goto 999;
                     if it>(500) then goto 999;
                     if colormonitor then textcolor(4)
                        else textcolor(12);
                     gotoxy(13,7);Write(word[it]);
                     if colormonitor then textcolor(0)
                        else textcolor(12);
                     answer(it);
                     r:=r+1;
                     textcolor(9); textbackground(12);
                     gotoxy(3,20);write('**      You have answered ',right,'            ');gotoxy(42,20);write('**');
                     gotoxy(3,21);
             if r=1 then write('**           question right and          ')
                     else write('**          questions right and         ');
                     gotoxy(42,21);write('**');
                     gotoxy(3,22);write('**                ',wrong,' wrong.             ');gotoxy(42,22);write('**');
                     delay(2000);
                     textcolor(0); textbackground(7);
                     end;
          keyset:=['y','Y','n','N'];
          clrscr;
          gotoxy(10,10);write('If you would like to continue, press -- Y -- .');
          gotoxy(10,12);write('  If you would like to stop, press  --  N -- .');
          repeat
                 read(kbd,key_ret);
                 key_ret:=upcase(key_ret);
                 until key_ret in keyset;
          if key_ret='Y' then
             begin
             r:=0;
             for a:= 1 to 500 do
                 begin
                 temp:=word[a];
                 word[a]:=def[a];
                 def[a]:=temp;
                 end;
             goto 999;
             end

          else halt;
          end;  {end of tutor}



begin {compu2tr }

    ami:=0;
    clrscr;
    Title_Screen;
    delay(2000);
    pulldownmenus;
    fl_tutor(ami);
end.  {end of program}